home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / webjump.el.z / webjump.el
Encoding:
Windows Setup INFormation  |  1998-05-21  |  18.4 KB  |  454 lines
  1. ;;; webjump.el --- programmable Web hotlist
  2.      
  3. ;; Copyright (C) 1996-1997 Free Software Foundation
  4.  
  5. ;; Author:    Neil W. Van Dyke <nwv@acm.org>
  6. ;; Created:   09-Aug-1996
  7. ;; Keywords:  comm www
  8. ;; X-URL:     http://www.cs.brown.edu/people/nwv/
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Change Log:
  28.  
  29. ;; [Version 1.5, 02-Jun-1997, nwv@acm.org] Prepared for first inclusion in GNU
  30. ;; Emacs distribution by merging in RMS' minor changes and moving some sample
  31. ;; Web site entries out.  Also updated Lycos and Yahoo sample entries.
  32.  
  33. ;; [Version 1.4, 17-Sep-1996, nwv@acm.org] Removed the evil "defconst-TEST"
  34. ;; that slipped into 1.3.  Organized webjump-sample-sites and modified the
  35. ;; content a bit.
  36.  
  37. ;; [Version 1.3, 30-Aug-1996, nwv@acm.org] Fixed broken `if' function in
  38. ;; `webjump-to-javaapi' (bugfix already posted).  Added `webjump-to-iwin'.
  39. ;; Added comment on purpose of `webjump-sample-sites'.  Added
  40. ;; `webjump-read-choice'.
  41.  
  42. ;; [Version 1.2, 16-Aug-1996, nwv@acm.org] Oops, got Gamelan mixed up with
  43. ;; Digital Espresso somehow.  Added `mirrors' builtin and used it for the
  44. ;; sample GNU Archive site.  Added some other sample sites.  Split sample sites
  45. ;; out into separate constant.  Misc. small changes.  Copyright has been
  46. ;; transferred to the FSF.
  47.  
  48. ;; [Version 1.1, 10-Aug-1996, nwv@acm.org] Added missing call to
  49. ;; `webjump-url-fix' (thanks to Istvan Marko <mi@bgytf.hu> for pointing this
  50. ;; out).  Added ``builtins'' concept in order to support `simple-query' builtin
  51. ;; for covering the majority of cases.  Added a couple more sample sites.
  52.  
  53. ;; [Version 1.0, 09-Aug-1996, nwv@acm.org] Wrote initial version and posted to
  54. ;; gnu.emacs.sources.
  55.  
  56. ;;; Commentary:
  57.  
  58. ;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can
  59. ;; quickly be invoked in your Web browser.  Each Web site in the hotlist has a
  60. ;; name, and you select the desired site name via a completing string prompt in
  61. ;; the minibuffer.  The URL for each Web site is defined as a static string or
  62. ;; a built-in or custom function, allowing interactive prompting for
  63. ;; site-specific queries and options.
  64.  
  65. ;; Note that WebJump was originally intended to complement your conventional
  66. ;; browser-based hotlist, not replace it.  (Though there's no reason you
  67. ;; couldn't use WebJump for your entire hotlist if you were so inclined.)
  68.  
  69. ;; The `webjump-sites' variable, which defines the hotlist, defaults to some
  70. ;; example sites.  You'll probably want to override it with your own favorite
  71. ;; sites.  The documentation for the variable describes the syntax.
  72.  
  73. ;; You may wish to add something like the following to your `.emacs' file:
  74. ;;
  75. ;;   (require 'webjump)
  76. ;;   (global-set-key "\C-cj" 'webjump)
  77. ;;   (setq webjump-sites
  78. ;;         (append '(
  79. ;;                   ("My Home Page" . "www.someisp.net/users/joebobjr/")
  80. ;;                   ("Pop's Site"   . "www.joebob-and-son.com/")
  81. ;;                   )
  82. ;;                 webjump-sample-sites))
  83. ;;
  84. ;; The above loads this package, binds `C-c j' to invoke WebJump, and adds your
  85. ;; personal favorite sites to the hotlist.
  86.  
  87. ;; The `webjump-sample-sites' variable mostly contains some site entries that
  88. ;; are expected to be generally relevant to most Emacs users.  Some additional
  89. ;; site entries are defined in the separate and more frequently updated
  90. ;; `webjump-plus' package, which is available from the author's Web site.
  91.  
  92. ;; The `browse-url' package is used to submit URLs to the browser, so any
  93. ;; browser-specific configuration should be done there.
  94.  
  95. ;; WebJump inherits a small amount code from my `altavista.el' package, and is
  96. ;; intended to obsolete that package.
  97.  
  98. ;;; Code:
  99.  
  100. ;;-------------------------------------------------------- Package Dependencies
  101.  
  102. (require 'browse-url)
  103.  
  104. ;;------------------------------------------------------------------- Constants
  105.  
  106. (defvar webjump-version "1.5")
  107.  
  108. (defvar webjump-sample-sites
  109.   '(
  110.  
  111.     ;; FSF, not including Emacs-specific.
  112.     ("GNU Project FTP Archive" .
  113.      [mirrors "ftp://prep.ai.mit.edu/pub/gnu/"
  114.               ;; ASIA:
  115.               "ftp://ftp.cs.titech.ac.jp"
  116.               "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/prep"
  117.               "ftp://cair-archive.kaist.ac.kr/pub/gnu"
  118.               "ftp://ftp.nectec.or.th/pub/mirrors/gnu"
  119.               ;; AUSTRALIA:
  120.               "ftp://archie.au/gnu"
  121.               "ftp://archie.oz/gnu"
  122.               "ftp://archie.oz.au/gnu"
  123.               ;; AFRICA:
  124.               "ftp://ftp.sun.ac.za/pub/gnu"
  125.               ;; MIDDLE-EAST:
  126.               "ftp://ftp.technion.ac.il/pub/unsupported/gnu"
  127.               ;; EUROPE:
  128.               "ftp://irisa.irisa.fr/pub/gnu"
  129.               "ftp://ftp.univ-lyon1.fr/pub/gnu"
  130.               "ftp://ftp.mcc.ac.uk"
  131.               "ftp://unix.hensa.ac.uk/mirrors/uunet/systems/gnu"
  132.               "ftp://src.doc.ic.ac.uk/gnu"
  133.               "ftp://ftp.ieunet.ie/pub/gnu"
  134.               "ftp://ftp.eunet.ch"
  135.               "ftp://nic.switch.ch/mirror/gnu"
  136.               "ftp://ftp.informatik.rwth-aachen.de/pub/gnu"
  137.               "ftp://ftp.informatik.tu-muenchen.de"
  138.               "ftp://ftp.win.tue.nl/pub/gnu"
  139.               "ftp://ftp.nl.net"
  140.               "ftp://ftp.etsimo.uniovi.es/pub/gnu"
  141.               "ftp://ftp.funet.fi/pub/gnu"
  142.               "ftp://ftp.denet.dk"
  143.               "ftp://ftp.stacken.kth.se"
  144.               "ftp://isy.liu.se"
  145.               "ftp://ftp.luth.se/pub/unix/gnu"
  146.               "ftp://ftp.sunet.se/pub/gnu"
  147.               "ftp://archive.eu.net"
  148.               ;; SOUTH AMERICA: 
  149.               "ftp://ftp.inf.utfsm.cl/pub/gnu"
  150.               "ftp://ftp.unicamp.br/pub/gnu"
  151.               ;; WESTERN CANADA:
  152.               "ftp://ftp.cs.ubc.ca/mirror2/gnu"
  153.               ;; USA:
  154.               "ftp://wuarchive.wustl.edu/systems/gnu"
  155.               "ftp://labrea.stanford.edu"
  156.               "ftp://ftp.digex.net/pub/gnu"
  157.               "ftp://ftp.kpc.com/pub/mirror/gnu"
  158.               "ftp://f.ms.uky.edu/pub3/gnu"
  159.               "ftp://jaguar.utah.edu/gnustuff"
  160.               "ftp://ftp.hawaii.edu/mirrors/gnu"
  161.               "ftp://uiarchive.cso.uiuc.edu/pub/gnu"
  162.               "ftp://ftp.cs.columbia.edu/archives/gnu/prep"
  163.               "ftp://gatekeeper.dec.com/pub/GNU"
  164.               "ftp://ftp.uu.net/systems/gnu"])
  165.     ("GNU Project Home Page" . "www.fsf.org")
  166.  
  167.     ;; Emacs.
  168.     ("Eieio" . "ftp.ultranet.com/pub/zappo/")
  169.     ("Emacs Lisp Archive" .
  170.      "ftp://archive.cis.ohio-state.edu/pub/gnu/emacs/elisp-archive/")
  171.     ("Insidious Big Brother Database" . "home.netscape.com/people/jwz/bbdb/")
  172.     ("Mailcrypt" . "cag-www.lcs.mit.edu/mailcrypt/")
  173.     ("WebJump" . "http://www.cs.brown.edu/people/nwv/projects/webjump/")
  174.     ("XEmacs Home" . "www.xemacs.org")
  175.     ("Yahoo: Emacs" .
  176.      "www.yahoo.com/Computers_and_Internet/Software/Text_Editors/Emacs/")
  177.  
  178.     ;; Internet search engines.
  179.     ("AltaVista" . 
  180.      [simple-query
  181.       "www.altavista.digital.com"
  182.       "www.altavista.digital.com/cgi-bin/query?pg=aq&what=web&fmt=.&q="
  183.       "&r=&d0=&d1="])
  184.     ("Archie" .
  185.      [simple-query "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl"
  186.            "hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl?query=" ""])
  187.     ("Lycos" .
  188.      [simple-query "www.lycos.com"
  189.                    "www.lycos.com/cgi-bin/pursuit?cat=lycos&query=" ""])
  190.     ("Yahoo" . 
  191.      [simple-query "www.yahoo.com" "search.yahoo.com/bin/search?p=" ""])
  192.  
  193.     ;; Misc. general interest.
  194.     ("Interactive Weather Information Network" . webjump-to-iwin)
  195.     ("Usenet FAQs" . 
  196.      [simple-query "www.cis.ohio-state.edu/hypertext/faq/usenet/FAQ-List.html"
  197.            "www.cis.ohio-state.edu/htbin/search-usenet-faqs/form?find="
  198.            ""])
  199.     ("RTFM Usenet FAQs by Group" .
  200.      "ftp://rtfm.mit.edu/pub/usenet-by-group/")
  201.     ("RTFM Usenet FAQs by Hierachy" .
  202.      "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/")
  203.     ("Webster" . 
  204.      [simple-query "c.gp.cs.cmu.edu:5103/prog/webster"
  205.            "gs213.sp.cs.cmu.edu/prog/webster?" ""])
  206.     ("X Consortium Archive". "ftp.x.org")
  207.     ("Yahoo: Reference" . "www.yahoo.com/Reference/")
  208.  
  209.     ;; Computer social issues, privacy, professionalism.
  210.     ("Association for Computing Machinery" . "www.acm.org")
  211.     ("Computer Professionals for Social Responsibility" . "www.cpsr.org/dox/")
  212.     ("Electronic Frontier Foundation" . "www.eff.org")
  213.     ("IEEE Computer Society" . "www.computer.org")
  214.     ("Pretty Good Privacy" . "web.mit.edu/network/pgp.html")
  215.     ("Risks Digest" . webjump-to-risks)
  216.  
  217.     ;; Fun.
  218.     ("Bastard Operator from Hell" . "www.replay.com/bofh/")
  219.  
  220.     )
  221.   "Sample hotlist for WebJump.  See the documentation for the `webjump'
  222. function and the `webjump-sites' variable.")
  223.  
  224. (defvar webjump-state-to-postal-alist
  225.   '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar")
  226.     ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct")
  227.     ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi")
  228.     ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia")
  229.     ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me")
  230.     ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi")
  231.     ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo")
  232.     ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv")
  233.     ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm")
  234.     ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd")
  235.     ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or")
  236.     ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc")
  237.     ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx")
  238.     ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va")
  239.     ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi")
  240.     ("Wyoming" . "wy")))
  241.  
  242. ;;------------------------------------------------------------ Option Variables
  243.  
  244. (defvar webjump-sites
  245.   webjump-sample-sites
  246.   "*Hotlist for WebJump.
  247.  
  248. The hotlist is represented as an association list, with the CAR of each cell
  249. being the name of the Web site, and the CDR being the definition for the URL of
  250. that site.  The URL definition can be a string (the URL), a vector (specifying
  251. a special \"builtin\" which returns a URL), a symbol (name of a function which
  252. returns a URL), or a list (which when `eval'ed yields a URL).
  253.  
  254. If the URL definition is a vector, then a \"builtin\" is used.  A builtin has a
  255. Lisp-like syntax, with the name as the first element of the vector, and any
  256. arguments as the following elements.  The three current builtins are `name',
  257. which returns the name of the site as the URL, `simple-query', which
  258. returns a URL that is a function of a query entered by the user, and `mirrors',
  259. which allows the user to select from among multiple mirror sites for the same
  260. content.
  261.  
  262. The first argument to the `simple-query' builtin is a static URL to use if the
  263. user enters a blank query.  The second and third arguments are the prefix and
  264. suffix, respectively, to add to the encoded query the user enters.  This
  265. builtin covers Web sites that have single-string searches with the query
  266. embedded in the URL.
  267.  
  268. The arguments to the `mirrors' builtin are URLs of mirror sites.
  269.  
  270. If the symbol of a function is given, then the function will be called with the
  271. Web site name (the one you specified in the CAR of the alist cell) as a
  272. parameter.  This might come in handy for various kludges.
  273.  
  274. For convenience, if the `http://', `ftp://', or `file://' prefix is missing
  275. from a URL, WebJump will make a guess at what you wanted and prepend it before
  276. submitting the URL.")
  277.  
  278. ;;------------------------------------------------------- Sample Site Functions
  279.  
  280. (defun webjump-to-iwin (name)
  281.   (let ((prefix "http://iwin.nws.noaa.gov/")
  282.         (state (webjump-read-choice name "state"
  283.                                     (append '(("Puerto Rico" . "pr"))
  284.                                             webjump-state-to-postal-alist))))
  285.     (if state
  286.         (concat prefix "iwin/" state "/"
  287.                 (webjump-read-choice name "option"
  288.                                      '(("Hourly Report" . "hourly")
  289.                                        ("State Forecast" . "state")
  290.                                        ("Local Forecast" . "local")
  291.                                        ("Zone Forecast" . "zone")
  292.                                        ("Short-Term Forecast" . "shortterm")
  293.                                        ("Weather Summary" . "summary")
  294.                                        ("Public Information" . "public")
  295.                                        ("Climatic Data" . "climate")
  296.                                        ("Aviation Products" . "aviation")
  297.                                        ("Hydro Products" . "hydro")
  298.                                        ("Special Weather" . "special")
  299.                                        ("Watches and Warnings" . "warnings"))
  300.                                      "zone")
  301.                 ".html")
  302.       prefix)))
  303.  
  304. (defun webjump-to-risks (name)
  305.   (let (issue volume)
  306.     (if (and (setq volume (webjump-read-number (concat name " volume")))
  307.          (setq issue  (webjump-read-number (concat name " issue"))))
  308.     (format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue)
  309.       "catless.ncl.ac.uk/Risks/")))
  310.  
  311. ;;-------------------------------------------------------------- Core Functions
  312.  
  313. ;;;###autoload
  314. (defun webjump ()
  315.   "Jumps to a Web site from a programmable hotlist.
  316.  
  317. See the documentation for the `webjump-sites' variable for how to customize the
  318. hotlist.
  319.  
  320. Please submit bug reports and other feedback to the author, Neil W. Van Dyke
  321. <nwv@acm.org>.
  322.  
  323. The latest version can be gotten from `http://www.cs.brown.edu/people/nwv/'.
  324. That Web site also contains `webjump-plus.el', a larger and more frequently
  325. updated sample WebJump hotlist."
  326.   (interactive)
  327.   (let* ((completion-ignore-case t)
  328.      (item (assoc (completing-read "WebJump to site: " webjump-sites nil t)
  329.               webjump-sites))
  330.      (name (car item))
  331.      (expr (cdr item)))
  332.     (funcall browse-url-browser-function
  333.          (webjump-url-fix
  334.           (cond ((not expr) "")
  335.             ((stringp expr) expr)
  336.             ((vectorp expr) (webjump-builtin expr name))
  337.             ((listp expr) (eval expr))
  338.             ((symbolp expr)
  339.              (if (fboundp expr)
  340.              (funcall expr name)
  341.                (error "WebJump URL function \"%s\" undefined." expr)))
  342.             (t (error "WebJump URL expression for \"%s\" invalid."
  343.                   name)))))))
  344.  
  345. (defun webjump-builtin (expr name)
  346.   (if (< (length expr) 1)
  347.       (error "WebJump URL builtin for \"%s\" empty." name))
  348.   (let ((builtin (aref expr 0)))
  349.     (cond
  350.      ((eq builtin 'mirrors)
  351.       (if (= (length expr) 1)
  352.           (error
  353.            "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg."))
  354.       (webjump-choose-mirror name (cdr (append expr nil))))
  355.      ((eq builtin 'name)
  356.       name)
  357.      ((eq builtin 'simple-query)
  358.       (webjump-builtin-check-args expr name 3)
  359.       (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3)))
  360.      (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid."
  361.            builtin name)))))
  362.  
  363. (defun webjump-builtin-check-args (expr name count)
  364.   (or (= (length expr) (1+ count))
  365.       (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args."
  366.          (aref expr 0) name count)))
  367.  
  368. (defun webjump-choose-mirror (name urls)
  369.   (webjump-read-url-choice (concat name " mirror")
  370.                            urls
  371.                            (webjump-mirror-default urls)))
  372.  
  373. (defun webjump-do-simple-query (name noquery-url query-prefix query-suffix)
  374.   (let ((query (webjump-read-string (concat name " query"))))
  375.     (if query
  376.     (concat query-prefix (webjump-url-encode query) query-suffix)
  377.       noquery-url)))
  378.  
  379. (defun webjump-mirror-default (urls)
  380.   ;; Note: This should be modified to apply some simple kludges/heuristics to
  381.   ;; pick a site which is likely "close".  As a tie-breaker among candidates
  382.   ;; judged equally desirable, randomness might be used.
  383.   (car urls))
  384.  
  385. (defun webjump-read-choice (name what choices &optional default)
  386.   (let* ((completion-ignore-case t)
  387.          (choice (completing-read (concat name " " what ": ") choices nil t)))
  388.     (if (webjump-null-or-blank-string-p choice)
  389.         default
  390.       (cdr (assoc choice choices)))))
  391.  
  392. (defun webjump-read-number (prompt)
  393.   ;; Note: I should make this more robust someday.
  394.   (let ((input (webjump-read-string prompt)))
  395.     (if input (string-to-number input))))
  396.   
  397. (defun webjump-read-string (prompt)
  398.   (let ((input (read-string (concat prompt ": "))))
  399.     (if (webjump-null-or-blank-string-p input) nil input)))
  400.   
  401. (defun webjump-read-url-choice (what urls &optional default)
  402.   ;; Note: Convert this to use `webjump-read-choice' someday.
  403.   (let* ((completions (mapcar (function (lambda (n) (cons n n)))
  404.                               urls))
  405.      (input (completing-read (concat what
  406.                                          ;;(if default " (RET for default)" "")
  407.                                          ": ")
  408.                                  completions
  409.                                  nil
  410.                                  t)))
  411.     (if (webjump-null-or-blank-string-p input)
  412.         default
  413.       (car (assoc input completions)))))
  414.  
  415. (defun webjump-null-or-blank-string-p (str)
  416.   (or (null str) (string-match "^[ \t]*$" str)))
  417.  
  418. (defun webjump-url-encode (str)
  419.   (mapconcat '(lambda (c)
  420.         (cond ((= c 32) "+")
  421.               ((or (and (>= c ?a) (<= c ?z))
  422.                (and (>= c ?A) (<= c ?Z))
  423.                (and (>= c ?0) (<= c ?9)))
  424.                (char-to-string c))
  425.               (t (upcase (format "%%%02x" c)))))
  426.          str
  427.          ""))
  428.  
  429. (defun webjump-url-fix (url)
  430.   (if (webjump-null-or-blank-string-p url)
  431.       ""
  432.     (webjump-url-fix-trailing-slash
  433.      (cond
  434.       ((string-match "^[a-zA-Z]+:" url) url)
  435.       ((string-match "^/" url) (concat "file://" url))
  436.       ((string-match "^\\([^\\./]+\\)" url)
  437.        (concat (if (string= (downcase (match-string 1 url)) "ftp")
  438.            "ftp"
  439.          "http")
  440.            "://"
  441.            url))
  442.       (t url)))))
  443.  
  444. (defun webjump-url-fix-trailing-slash (url)
  445.   (if (string-match "^[a-zA-Z]+://[^/]+$" url)
  446.       (concat url "/")
  447.     url))
  448.  
  449. ;;-----------------------------------------------------------------------------
  450.  
  451. (provide 'webjump)
  452.  
  453. ;; webjump.el ends here
  454.